(defprop impur (
 EQUIV
 EQUIV1
 MATCH
 UNMATCH
 mkfoo
 labl
 lab
 remv
 fib
 fibon
 fibloop
)impurfns)

(DEFUN EQUIV (X Y) (NOT (EQ (EQUIV1 X Y NIL) 'LOSE)))

(DEFUN EQUIV1 (X Y U) 
       (COND ((EQ U 'LOSE) 'LOSE)
	     ((OR (EQ X Y) (MATCH X Y U)) U)
	     ((OR (ATOM X) (ATOM Y) (UNMATCH X Y U)) 'LOSE)
	     (T (EQUIV1 (CAR X)
			(CAR Y)
			(EQUIV1 (CDR X)
				(CDR Y)
				(CONS (CONS X Y) U))))))

(DEFUN MATCH (X Y U) 
       (AND (NOT (NULL U))
	    (OR (AND (EQ X (CAAR U)) (EQ Y (CDAR U)))
		(MATCH X Y (CDR U)))))

(DEFUN UNMATCH (X Y U) 
       (AND (NOT (NULL U))
	    (OR (EQ X (CAAR U))
		(EQ Y (CDAR U))
		(UNMATCH X Y (CDR U)))))

;;; example of using RPLACA to simulate the label construct

(defun mkfoo()
    (prog () 
      (setq foo 
	    '(lambda (x) (cond ((atom x) x)
		   (t (foo (car x))) )))
      (rplaca (cadr (caddr (caddr foo))) foo)
      (return 'foo)
    ))


(defun labl (name exp) (lab (putprop name exp 'expr)))

(defun lab (x)
  (prog nil
    (cond ((atom x) (return nil)) )
    (lab (car x))
    (lab (cdr x))
    (cond ((eq (car x) name ) (rplaca x exp)) )
    (cond ((eq (cdr x) name ) (rplacd x exp)) )
    NIL
 ) )


(labl 'foo '(lambda (x) (cond ((atom x) x) (t (foo (cdr x))))))
(labl 'fringe '(lambda (x) (cond ((atom x) (ncons x)) 
				 (t (append (fringe (car x)) (fringe (cdr x)))) )))


;;; using rplacs to remove some atom from a list

(defun remv (x u)
  (prog (u1)
  lu
    (cond ((null u) (return u)) )
    (cond ((eq (car u) x) (setq u (cdr u)) (go lu)))
    (setq u1 u)
  lu1
    (cond ((null (cdr u1)) (return u)) )
    (cond ((eq (cadr u1) x) (rplacd u1 (cddr u1))(go lu1)) )
    (setq u1 (cdr u1))
    (go lu1)
  ) )


;;;learning fibonacci program


(defun fib (n)
    ((lambda (fiblist)
	(prog (l)
	    (cond ((or (eq n 0) (eq n 1)) (return 1)))
	    (setq l fiblist)
	    (print fiblist)
	 fibloop
	    (cond ((null (cddr l)) 
		   (rplacd (cdr l) (list (plus (car l) (cadr l))))))
	    (cond ((eq n 2) (return (caddr l))))
	    (setq n (sub1 n))
	    (setq l (cdr l))
	    (go fibloop) ) )
     '(1 1))
)

(defun fibon (n) 
  (cond ((or (eq n 0) (eq n 1)) 1) (t (fibloop n '(1 1))) ))

(defun fibloop (n l)
  (cond ((null (cddr l))
	 (cond ((eq n 2) (cadr (rplacd (cdr l) (list (plus (car l) (cadr l))))))
	       (t (fibloop (sub1 n) (rplacd (cdr l) (list (plus (car l) (cadr l)))))) ))
	(t (cond ((eq n 2) (caddr l))(t (fibloop (sub1 n) (cdr l))))) ))